home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / input.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  62KB  |  1,652 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;
  22. ;;; Change history:
  23. ;;;
  24. ;;;  Date    Author    Description
  25. ;;; -------------------------------------------------------------------------------------
  26. ;;; 12/10/87    LGO    Created
  27.  
  28. (in-package 'xlib :use '(lisp))
  29.  
  30. (export '(
  31.       event-listen
  32.       queue-event
  33.       process-event
  34.       event-case
  35.       event-cond
  36.       discard-current-event
  37.       request-error
  38.       value-error
  39.       window-error
  40.       pixmap-error
  41.       atom-error
  42.       cursor-error
  43.       font-error
  44.       match-error
  45.       drawable-error
  46.       access-error
  47.       alloc-error
  48.       colormap-error
  49.       gcontext-error
  50.       id-choice-error
  51.       name-error
  52.       length-error
  53.       implementation-error
  54.       request-error
  55.       resource-error
  56.       unknown-error
  57.       access-error
  58.       alloc-error
  59.       atom-error
  60.       colormap-error
  61.       cursor-error
  62.       drawable-error
  63.       font-error
  64.       gcontext-error
  65.       id-choice-error
  66.       illegal-request-error
  67.       length-error
  68.       match-error
  69.       name-error
  70.       pixmap-error
  71.       value-error
  72.       window-error
  73.       implementation-error
  74.       type-error
  75.       closed-display
  76.       lookup-error
  77.       connection-failure
  78.       reply-length-error
  79.       reply-timeout
  80.       server-disconnect
  81.       sequence-error
  82.       unexpected-reply
  83.       missing-parameter
  84.       invalid-font
  85.       device-busy
  86.       get-external-event-code
  87.       define-extension
  88.       extension-opcode
  89.       define-error
  90.       decode-core-error
  91.       declare-event
  92.       ))
  93.  
  94. ;; Event Resource
  95. (defvar *event-free-list* nil) ;; List of unused (processed) events
  96.  
  97. (eval-when (eval compile load)
  98. (defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
  99. (defvar *event-key-vector* (make-array *max-events* :initial-element nil)
  100.   "Vector of event keys - See define-event")
  101. )
  102. (defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
  103.   "Vector of event handler functions - See declare-event")
  104. (defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
  105.   "Vector of event handler functions - See declare-event")
  106. (defvar *event-send-vector* (make-array *max-events* :initial-element nil)
  107.   "Vector of event sending functions - See declare-event")
  108.  
  109. (defun allocate-event ()
  110.   (or (atomic-pop *event-free-list*)
  111.       (make-reply-buffer *replysize*)))
  112.  
  113. (defun deallocate-event (event)
  114.   (atomic-push event *event-free-list*))
  115.  
  116. ;; Extensions are handled as follows:
  117. ;; DEFINITION:    Use DEFINE-EXTENSION
  118. ;;
  119. ;; CODE:    Use EXTENSION-CODE to get the X11 opcode for an extension.
  120. ;;        This looks up the code on the display-extension-alist.
  121. ;;
  122. ;; EVENTS:    Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
  123. ;;        at LOAD time to define an internal event-code number
  124. ;;        (stored in the 'event-code property of the event-name)
  125. ;;        used to index the following vectors:
  126. ;;        *event-key-vector*     Used for getting the event-key
  127. ;;        *event-macro-vector*    Used for getting the event-parameter getting macros
  128. ;;
  129. ;;        The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
  130. ;;        a server event-code into an internal event-code used to index the following
  131. ;;        vectors:
  132. ;;        *event-handler-vector*    Used for getting the event-handler function
  133. ;;        *event-send-vector*    Used for getting the event-sending function
  134. ;;
  135. ;;        The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
  136. ;;        internal event-codes to external (server) codes.
  137. ;;
  138. ;; ERRORS:    Use DEFINE-ERROR to define new error decodings.
  139. ;;
  140.  
  141.  
  142. ;; Any event-code greater than 34 is for an extension
  143. (defparameter *first-extension-event-code* 35)
  144.  
  145. (defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
  146.  
  147. (defmacro define-extension (name &key events errors)
  148.   ;; Define extension NAME with EVENTS and ERRORS.
  149.   ;; Note: The case of NAME is important.
  150.   ;; To define the request, Use:
  151.   ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
  152.   ;;     See the REQUESTS file for lots of examples.
  153.   ;; To define event handlers, use declare-event.
  154.   ;; To define error handlers, use declare-error and define-condition.
  155.   (declare (type stringable name)
  156.        (type list events errors))
  157.   (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
  158.     (event-list (mapcar #'canonicalize-event-name events)))
  159.     `(eval-when (compile load eval)
  160.        (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
  161.                 (delete ',name-symbol *extensions* :key #'car))))))
  162.  
  163. (eval-when (compile eval load)
  164. (defun canonicalize-event-name (event)
  165.   ;; Returns the event name keyword given an event name stringable
  166.   (declare (type stringable event))
  167.   (declare-values event-key)
  168.   (kintern event))
  169. ) ;; end eval-when
  170.  
  171. (eval-when (compile eval load)
  172. (defun allocate-extension-event-code (name)
  173.   ;; Allocate an event-code for an extension
  174.   ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
  175.   ;; The event-code is used at compile-time by macros to index the following vectors:
  176.   ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
  177.   (let ((event-code (get name 'event-code)))
  178.     (declare (type (or null card8) event-code))
  179.     (unless event-code
  180.       ;; First ensure the name is for a declared extension
  181.       (unless (dolist (extension *extensions*)
  182.         (when (member name (second extension))
  183.           (return t)))
  184.     (x-type-error name 'event-key))
  185.       (setq event-code (position nil *event-key-vector*
  186.                  :start *first-extension-event-code*))
  187.       (setf (aref *event-key-vector* event-code) name)
  188.       (setf (get name 'event-code) event-code))
  189.     event-code))
  190. ) ;; end eval-when
  191.  
  192. (defun get-internal-event-code (display code)
  193.   ;; Given an X11 event-code, return the internal event-code.
  194.   ;; The internal event-code is used for indexing into the following vectors:
  195.   ;; *event-key-vector* *event-handler-vector* *event-send-vector*
  196.   ;; Returns NIL when the event-code is for an extension that isn't handled.
  197.   (declare (type display display)
  198.        (type card8 code))
  199.   (declare-values (or nil card8))
  200.   (setq code (logand #x7f code))
  201.   (if (< code *first-extension-event-code*)
  202.       code
  203.     (let* ((code-offset (- code *first-extension-event-code*))
  204.        (event-extensions (display-event-extensions display))
  205.        (code (if (< code-offset (length event-extensions))
  206.              (aref event-extensions code-offset)
  207.            0)))
  208.       (declare (type card8 code-offset code))
  209.       (when (zerop code)
  210.     (x-cerror "Ignore the event"
  211.           'unimplemented-event :event-code code :display display))
  212.       code)))
  213.  
  214. (defun get-external-event-code (display event)
  215.   ;; Given an X11 event name, return the event-code
  216.   (declare (type display display)
  217.        (type event-key event))
  218.   (declare-values card8)
  219.   (let ((code (get-event-code event)))
  220.     (declare (type (or null card8) code))
  221.     (when (>= code *first-extension-event-code*)
  222.       (setq code (+ *first-extension-event-code*
  223.             (or (position code (display-event-extensions display))
  224.             (x-error 'undefined-event :display display :event-name event)))))
  225.     code))
  226.  
  227. (defmacro extension-opcode (display name)
  228.   ;; Returns the major opcode for extension NAME.
  229.   ;; This is a macro to enable NAME to be interned for fast run-time
  230.   ;; retrieval. 
  231.   ;; Note: The case of NAME is important.
  232.   (declare (type display display)
  233.        (type stringable name))
  234.   (declare-values card8)
  235.   (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
  236.     `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
  237.      (x-error 'absent-extension :name ',name-symbol :display ,display))))
  238.  
  239. (defun initialize-extensions (display)
  240.   ;; Initialize extensions for DISPLAY
  241.   (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
  242.     (extension-alist nil))
  243.     (declare (type vector event-extensions)
  244.          (type list extension-alist))
  245.     (dolist (extension *extensions*)
  246.       (let ((name (first extension))
  247.         (events (second extension)))
  248.     (declare (type keyword name)
  249.          (type list events))
  250.     (multiple-value-bind (major-opcode first-event first-error)
  251.         (query-extension display name)
  252.       (declare (type (or null card8) major-opcode first-event first-error))
  253.       (when (and major-opcode (plusp major-opcode))
  254.         (push (list name major-opcode first-event first-error)
  255.           extension-alist)
  256.         (when (plusp first-event) ;; When there are extension events
  257.           ;; Grow extension vector when needed
  258.           (let ((max-event (- (+ first-event (length events))
  259.                   *first-extension-event-code*)))
  260.         (declare (type card8 max-event))
  261.         (when (>= max-event (length event-extensions))
  262.           (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
  263.                             :initial-element 0)))
  264.             (declare (type vector new-extensions))
  265.             (replace new-extensions event-extensions)
  266.             (setq event-extensions new-extensions))))
  267.           (dolist (event events)
  268.         (declare (type symbol event))
  269.         (setf (aref event-extensions (- first-event *first-extension-event-code*))
  270.               (get-event-code event))
  271.         (incf first-event)))))))
  272.     (setf (display-event-extensions display) event-extensions)
  273.     (setf (display-extension-alist display) extension-alist)))
  274.  
  275. ;;
  276. ;; Reply handlers
  277. ;;
  278.  
  279. (defun wait-for-reply (display expected-size)
  280.   ;; Wait for a reply to a request.
  281.   ;; Expected-size is the length in BYTES,
  282.   ;;   or NIL to only read the first 32 bytes,
  283.   ;;   or T to read in the whole thing.
  284.   ;; Returns with REPLY in the reply-buffer in DISPLAY
  285.   ;; Handle error and event packets that are encountered
  286.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  287.   (declare (type display display)
  288.        (type (or integer (member nil t)) expected-size))
  289.   (declare-values length-in-bytes)
  290.   (buffer-force-output display)
  291.   (do ((sequence-error nil)
  292.        (req-sequence (ldb (byte 16 0) (buffer-request-number display))))
  293.       (nil) ;; forever
  294.     (setf (display-waiting-reply-p display) t) ;; indicate awaiting reply
  295.     (with-input-lock (display)
  296.       (reading-buffer-reply (display)
  297.     ;; If waiting-reply-p is :in-buffer then the reply was read in while
  298.     ;; waiting for the input lock (see wait-for-event)
  299.     (unless (eq (display-waiting-reply-p display) :in-buffer)
  300.       ;; Loop for reply-timeout condition return
  301.       (do ((timeout *reply-timeout* (floor timeout 0.666s0))
  302.            (eofp))
  303.           (()) ;; forever
  304.         (setq eofp (buffer-input display buffer-bbuf 0 *replysize* timeout))
  305.         (if eofp
  306.         (if (eq eofp :timeout)
  307.             (if sequence-error
  308.             (progn
  309.               (x-cerror "Proceed, altering display sequence number"
  310.                     'sequence-error
  311.                     :display display
  312.                     :req-sequence req-sequence
  313.                     :msg-sequence sequence-error)
  314.               (setf (buffer-request-number display) sequence-error
  315.                 req-sequence sequence-error)
  316.               (return nil))
  317.               (x-cerror "Retry with longer timeout"
  318.                 'reply-timeout
  319.                 :display display
  320.                 :timeout timeout))
  321.           (progn
  322.             (setf (display-dead display) t)
  323.             (x-error 'server-disconnect :display display)))
  324.           (return nil))))
  325.     (case (read-card8 0) ;; Type
  326.       (0                    ; Error
  327.        (report-error display (buffer-reply-buffer display)))
  328.       (1                    ; Normal reply
  329.         (let ((msg-sequence (read-card16 2))      ;; Message sequence number
  330.           (length (+ (* (read-card32 4) 4) *replysize*))) ;; Length in bytes
  331.           (if (= msg-sequence req-sequence)    ; Check for reply out of sequence
  332.           (progn 
  333.             (when expected-size
  334.               (if (and (not (eq expected-size t))
  335.                    (> expected-size length))
  336.               (x-error 'reply-length-error
  337.                    :display display
  338.                    :expected-length expected-size
  339.                    :reply-length length)
  340.             (progn
  341.               (if (<= length (reply-size (buffer-reply-buffer display)))
  342.                   (buffer-input display buffer-bbuf *replysize* length)
  343.                 (progn
  344.                   ;; reply buffer too small (should never happen!)
  345.                   (cerror "Grow the reply buffer"
  346.                       "Reply buffer too small, increase to ~d bytes"
  347.                       length)
  348.                   ;; Grow it
  349.                   (let* ((new-buffer (make-reply-buffer (+ length 64)))
  350.                      (new-bbuf (reply-ibuf8 new-buffer)))
  351.                 (buffer-replace new-bbuf buffer-bbuf 0 *replysize*)
  352.                 (buffer-input display new-bbuf *replysize* length)
  353.                 (setf (buffer-reply-buffer display) new-buffer)))))))
  354.             (setf (display-waiting-reply-p display) nil)
  355.             (return length))
  356.         ;; Reply out of sequence
  357.         (if (> msg-sequence req-sequence)
  358.             (progn
  359.               (x-cerror "Proceed, altering display sequence number"
  360.                 'sequence-error
  361.                 :display display
  362.                 :req-sequence req-sequence
  363.                 :msg-sequence msg-sequence)
  364.               (setf (buffer-request-number display) msg-sequence))
  365.           ;; We usually get here because of an abort while waiting for a reply
  366.           ;; Loop back around and read another reply (hopefully the one we want)
  367.           (progn
  368.             ;; **** debug *****
  369.             (format t "~%wait-for-reply recovering from sequence-error. ~
  370.                      Expected ~d Got ~d" req-sequence msg-sequence)
  371.             ;; Flush input
  372.             (buffer-input display buffer-bbuf *replysize* length *reply-timeout*)
  373.             (setq sequence-error msg-sequence))))))
  374.       (otherwise                ; Event
  375.         ;; Push the event in the input buffer on the display's event queue
  376.         (let ((event (allocate-event)))
  377.           ;; Copy into event from reply buffer
  378.           (buffer-replace (reply-ibuf8 event)
  379.                   (reply-ibuf8 (buffer-reply-buffer display))
  380.                   0
  381.                   *replysize*)
  382.           (setf (event-code event)
  383.             (get-internal-event-code display (read-card8 0)))
  384.           (enqueue-event event display))))))))
  385.  
  386. ;; Its necessary to have a lock on input operations, to prevent two
  387. ;; process from reading from the server at the same time.  Its also
  388. ;; necessary to allow one process to be hung inside wait-for-event
  389. ;; waiting for an event while another process makes requests and waits
  390. ;; for replies.  With this situation, its possible that the process
  391. ;; that reads the reply is different from the process waiting for the
  392. ;; reply.  The process waiting for the reply must not hang because
  393. ;; there's another high priority process that's always waiting for
  394. ;; events, and has the input lock.  Because of this, wait-for-event
  395. ;; will wait for, and immediately give-up the display lock, when the
  396. ;; waiting-reply-p flag is set in the display.  This is sufficient to
  397. ;; break the deadlock.
  398.  
  399. (defun wait-for-event (display timeout force-output-p)
  400.   ;; Wait for an event.
  401.   ;; Handle error and event packets that are encountered
  402.   ;; Returns :TIMEOUT on timeout, else NIL.
  403.   (declare (type display display)
  404.        (type (or null number) timeout))
  405.   (declare-values eof-or-timeout)
  406.   (do ((do-force-output nil))
  407.       (nil) ;; forever
  408.     (block retry
  409.       (when (display-waiting-reply-p display) ;; See comments above
  410.     (with-display (display)
  411.       ;; Flag whould be already NIL.  Reset it here incase wait-for-reply aborted.
  412.       (setf (display-waiting-reply-p display) nil)))
  413.       ;; When first pass determined no input available
  414.       (when do-force-output
  415.     (setq do-force-output nil)        ; To avoid deadlocks, avoid display
  416.     (display-force-output display)        ; operations inside with-input-lock.
  417.     (when (and timeout (zerop timeout))
  418.       (return :timeout)))            ; Optimize zero timeout case.
  419.       (with-input-lock (display)
  420.     ;; Return if events read while waiting for locks
  421.     (when (display-new-events display)
  422.       (return nil))
  423.     ;; Give up input-lock if waiting event
  424.     (when (display-waiting-reply-p display)
  425.       (return-from retry))
  426.     (let ((event (allocate-event))
  427.           (eofp :timeout))
  428.       (reading-event (event)
  429.         ;; Check for input pending
  430.         (when force-output-p
  431.           (setq force-output-p nil)
  432.           ;; Read with timeout = 0, which doesn't hang when no input available
  433.           (when (setq eofp (buffer-input display buffer-bbuf 0 *replysize* 0))
  434.         (deallocate-event event)
  435.         (setq do-force-output t)    ; Loop back and force output
  436.         (return-from retry)))        ; when no available input
  437.         ;; Hang waiting for an event
  438.         (when eofp
  439.           (when (eq eofp :timeout)
  440.         (setq eofp (buffer-input display buffer-bbuf 0 *replysize* timeout)))
  441.           (when eofp
  442.         (deallocate-event event)
  443.         (if (eq eofp :timeout)
  444.             (return eofp)
  445.             (progn
  446.               (x-error 'server-disconnect :display display)
  447.               (setf (display-dead display) t)))))
  448.         ;; Check for replies and errors
  449.         (let ((type (read-card8 0)))
  450.           (case type
  451.         (0                ; Error
  452.           (if (display-lock display)
  453.               (buffer-replace (buffer-obuf8 display)
  454.                       buffer-bbuf
  455.                       0
  456.                       *replysize*)
  457.               (report-error display event)))
  458.         (1                ; Normal reply
  459.           (if (display-waiting-reply-p display)
  460.               (progn
  461.             (buffer-replace (reply-ibuf8 (display-reply-buffer display))
  462.                     buffer-bbuf
  463.                     0
  464.                     *replysize*)
  465.             (setf (display-waiting-reply-p display) :in-buffer))
  466.               (x-cerror "Ignore"
  467.                 'unexpected-reply
  468.                 :display display
  469.                 :req-sequence (ldb (byte 16 0) (buffer-request-number display))
  470.                 :msg-sequence (read-card16 2)
  471.                 :length (+ (* (read-card32 4) 4) *replysize*))))
  472.         (otherwise            ; Event
  473.           (setf (event-code event)
  474.             (get-internal-event-code display (read-card8 0)))
  475.           (enqueue-event event display)
  476.           (return nil))))))))))
  477.  
  478. ;; The cons before the current event.
  479. ;; NIL outside EVENT-LOOP [used by event-case, event-cond, process-event]
  480. (defvar *recursive-event-queue* nil)
  481.  
  482. (defun event-listen (display &optional (timeout 0))
  483.   (declare (type display display)
  484.        (type (or null number) timeout))
  485.   ;; Returns the number of events queued locally, if any, else nil.  Hangs waiting
  486.   ;; for events, forever if timeout is nil, else for the specified number of seconds.
  487.   (let ((queue (or *recursive-event-queue*
  488.            (display-event-queue display))))
  489.     (if (cdr queue)
  490.     (length (cdr queue))
  491.       (wrap-event-listen
  492.     (wait-for-event display timeout nil)
  493.     (and (cdr queue) (length (cdr queue)))))))
  494.  
  495. (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
  496.   ;; The event is put at the head of the queue if append-p is nil, else the tail.
  497.   ;; Additional arguments depend on event-key, and are as specified above with
  498.   ;; declare-event, except that both resource-ids and resource objects are accepted
  499.   ;; in the event components.
  500.   (declare (type display display)
  501.        (type event-key event-key)
  502.        (type boolean append-p send-event-p))
  503.   (unless (get event-key 'event-code)
  504.     (x-type-error event-key 'event-key))
  505.   (let* ((event (allocate-event))
  506.      (buffer (reply-ibuf8 event))
  507.      (event-code (get event-key 'event-code)))
  508.     (unless event-code (x-type-error event-key 'event-key))
  509.     (setf (event-code event) event-code)
  510.     (with-display (display)
  511.       (apply (aref *event-send-vector* event-code) display args)
  512.       (buffer-replace buffer
  513.               (display-obuf8 display)
  514.               0
  515.               *replysize*
  516.               (index+ 12 (buffer-boffset display)))
  517.       (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
  518.         (aref buffer 2) 0
  519.         (aref buffer 3) 0))
  520.     (with-event-queue (display)
  521.       (if append-p
  522.       (enqueue-event event display)
  523.     (with-event-queue-internal (display)
  524.       (let ((queue (display-event-queue display)))
  525.         (setf (cdr queue) (cons event (cdr queue)))))))))
  526.  
  527. (defun enqueue-event (new-event display)
  528.   ;; Place EVENT at the end of the event queue for DISPLAY
  529.   (let ((event (list new-event)))
  530.     (declare (type list event))
  531.     (let* ((event-code (event-code new-event))
  532.        (event-key (and (< event-code (length *event-key-vector*))
  533.                (aref *event-key-vector* event-code))))
  534.       (if (null event-key)
  535.       (cerror "Ignore this event" "No handler for ~s event" event-key)
  536.     (with-event-queue-internal (display)
  537.       (let ((new (display-new-events display)))
  538.         (declare (type list new))
  539.         (if new
  540.         (setf (display-new-events display) (nconc new event))
  541.           (progn
  542.         (setf (display-new-events display) event)
  543.         (let ((old (display-event-queue display)))
  544.           (setf (display-event-queue display) (nconc old event)))))))))))
  545.  
  546.  
  547. (defmacro define-event (name code)
  548.   `(eval-when (eval compile load)
  549.      (setf (aref *event-key-vector* ,code) ',name)
  550.      (setf (get ',name 'event-code) ,code)))
  551.  
  552. ;; Event names.  Used in "type" field in XEvent structures.  Not to be
  553. ;; confused with event masks above.  They start from 2 because 0 and 1
  554. ;; are reserved in the protocol for errors and replies. */
  555.  
  556. (define-event :key-press 2)
  557. (define-event :key-release 3)
  558. (define-event :button-press 4)
  559. (define-event :button-release 5)
  560. (define-event :motion-notify 6)
  561. (define-event :enter-notify 7)
  562. (define-event :leave-notify 8)
  563. (define-event :focus-in 9)
  564. (define-event :focus-out 10)
  565. (define-event :keymap-notify 11)
  566. (define-event :exposure 12)
  567. (define-event :graphics-exposure 13)
  568. (define-event :no-exposure 14)
  569. (define-event :visibility-notify 15)
  570. (define-event :create-notify 16)
  571. (define-event :destroy-notify 17)
  572. (define-event :unmap-notify 18)
  573. (define-event :map-notify 19)
  574. (define-event :map-request 20)
  575. (define-event :reparent-notify 21)
  576. (define-event :configure-notify 22)
  577. (define-event :configure-request 23)
  578. (define-event :gravity-notify 24)
  579. (define-event :resize-request 25)
  580. (define-event :circulate-notify 26)
  581. (define-event :circulate-request 27)
  582. (define-event :property-notify 28)
  583. (define-event :selection-clear 29)
  584. (define-event :selection-request 30)
  585. (define-event :selection-notify 31)
  586. (define-event :colormap-notify 32)
  587. (define-event :client-message 33)
  588. (define-event :mapping-notify 34)
  589.  
  590.  
  591. (defmacro declare-event (event-codes &body declares)
  592.   ;; Used to indicate the keyword arguments for handler functions in
  593.   ;; process-event and event-case.
  594.   ;; Generates the functions used in SEND-EVENT.
  595.   ;; A compiler warning is printed when all of EVENT-CODES are not
  596.   ;; defined by a preceding DEFINE-EXTENSION.
  597.   ;; The body is a list of declarations, each of which has the form:
  598.   ;; (type . items)  Where type is a data-type, and items is a list of
  599.   ;; symbol names.  The item order corresponds to the order of fields
  600.   ;; in the event sent by the server.  An item may be a list of items.
  601.   ;; In this case, each item is aliased to the same event field.
  602.   ;; This is used to give all events an EVENT-WINDOW item.
  603.   ;; See the INPUT file for lots of examples.
  604.   (declare (type (or keyword list) event-codes)
  605.        (type (alist (field-type symbol) (field-names list))
  606.                  declares))
  607.   (when (atom event-codes) (setq event-codes (list event-codes)))
  608.   (setq event-codes (mapcar #'canonicalize-event-name event-codes))
  609.   (let* (get-code get-index get-sizes
  610.      put-code put-index put-sizes keywords
  611.      (name (first event-codes))
  612.      (get-macro (xintern name '-event-get-macro))
  613.      (get-function (xintern name '-event-get))
  614.      (put-function (xintern name '-event-put))
  615.      (*buffer* #-kcl (gensym)
  616.            ;; XXX
  617.            #+kcl '*kcl-internal-buffer-symbol-needed-because-of-the-compiler-bug*
  618.            ))
  619.     (multiple-value-setq (get-code get-index get-sizes)
  620.       (get-put-items 2 declares nil
  621.              #'(lambda (type index item args)
  622.              (flet ((event-get (type index item args)
  623.                        (unless (member type '(pad8 pad16))
  624.                          `(,(kintern item)
  625.                            (,(getify type) ,index ,@args)))))
  626.                (if (atom item)
  627.                    (event-get type index item args)
  628.                  (mapcan #'(lambda (item)
  629.                      (event-get type index item args))
  630.                      item))))))
  631.     (multiple-value-setq (put-code put-index put-sizes)
  632.       (get-put-items 2 declares t
  633.              #'(lambda (type index item args)
  634.              (unless (member type '(pad8 pad16))
  635.                (if (atom item)
  636.                    (progn
  637.                  (push item keywords)
  638.                  `((,(putify type) ,index ,item ,@args)))
  639.                  (let ((names (mapcar #'(lambda (name) (kintern name))
  640.                           item)))
  641.                    (setq keywords (append item keywords))
  642.                    `((,(putify type) ,index
  643.                   (check-consistency ',names ,@item) ,@args))))))))
  644.     get-index put-index                ; not used
  645.     `(within-definition (,name declare-event)
  646.        (defun ,get-macro (display event-key variable)
  647.      ;; Note: we take pains to macroexpand the get-code here to enable application
  648.      ;; code to be compiled without having the CLX macros file loaded.
  649.      (subst display ',*buffer*
  650.         (getf `(:display (the display ,display)
  651.             :event-key (the keyword ,event-key)
  652.             :event-code (the card8 (logand #x7f (read-card8 0)))
  653.             :send-event-p (the boolean (logbitp 7 (read-card8 0)))
  654.             ,@',(mapcar #'macroexpand get-code))
  655.               variable)))
  656.  
  657.        (defun ,get-function (display event handler)
  658.      (compiler-let ((*buffer* 'display))
  659.        (reading-event (event :sizes (8 16 ,@get-sizes))
  660.          (funcall handler
  661.               :display display
  662.               :event-key (aref *event-key-vector* (event-code event))
  663.               :event-code (logand #x7f (card8-get 0))
  664.               :send-event-p (logbitp 7 (card8-get 0))
  665.               ,@get-code))))
  666.  
  667.        (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) &allow-other-keys)
  668.      ,(when (member 'sequence keywords)
  669.         `(unless sequence (setq sequence (display-request-number display))))
  670.      (writing-buffer-send (display :sizes ,put-sizes
  671.                        :index (index+ (buffer-boffset display) 12))
  672.        ,@put-code))
  673.        
  674.        ,@(mapcar #'(lambda (name)
  675.              (allocate-extension-event-code name)
  676.              `(let ((event-code (or (get ',name 'event-code)
  677.                         (allocate-extension-event-code ',name))))
  678.             (setf (aref *event-macro-vector* event-code)
  679.                   (function ,get-macro))
  680.             (setf (aref *event-handler-vector* event-code)
  681.                   (function ,get-function))
  682.             (setf (aref *event-send-vector* event-code)
  683.                   (function ,put-function))))
  684.          event-codes)
  685.        ',name)))
  686.  
  687. (defun check-consistency (names &rest args)
  688.   ;; Ensure all args are nil or have the same value.
  689.   ;; Returns the consistent non-nil value.
  690.   (let ((value (car args)))
  691.     (dolist (arg (cdr args))
  692.       (if value
  693.       (when (and arg (not (eq arg value)))
  694.         (x-error 'inconsistent-parameters
  695.              :parameters (mapcan #'list names args)))
  696.     (setq value arg)))
  697.     value))
  698.  
  699. (declare-event (:key-press :key-release :button-press :button-release)
  700.   ;; for key-press and key-release, code is the keycode
  701.   ;; for button-press and button-release, code is the button number
  702.   (data code)
  703.   (card16 sequence)
  704.   (card32 time)
  705.   (window root (window event-window))
  706.   ((or null window) child)
  707.   (int16 root-x root-y x y)
  708.   (card16 state)
  709.   (boolean same-screen-p)
  710.   )
  711.  
  712. (declare-event :motion-notify
  713.   ((data boolean) hint-p)
  714.   (card16 sequence)
  715.   (card32 time)
  716.   (window root (window event-window))
  717.   ((or null window) child)
  718.   (int16 root-x root-y x y)
  719.   (card16 state)
  720.   (boolean same-screen-p))
  721.  
  722. (declare-event (:enter-notify :leave-notify)
  723.   ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
  724.   (card16 sequence)
  725.   (card32 time)
  726.   (window root (window event-window))
  727.   ((or null window) child)
  728.   (int16 root-x root-y x y)
  729.   (card16 state)
  730.   ((member8 :normal :grab :ungrab) mode)
  731.   ((bit 0) focus-p)
  732.   ((bit 1) same-screen-p))
  733.  
  734. (declare-event (:focus-in :focus-out)
  735.   ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
  736.           :pointer :pointer-root :none))
  737.    kind)
  738.   (card16 sequence)
  739.   (window (window event-window))
  740.   ((member8 :normal :while-grabbed :grab :ungrab) mode))
  741.  
  742. (declare-event :keymap-notify
  743.   ((bit-vector256 0) keymap))
  744.  
  745. (declare-event :exposure
  746.   (card16 sequence)
  747.   (window (window event-window))
  748.   (card16 x y width height count))
  749.  
  750. (declare-event :graphics-exposure
  751.   (card16 sequence)
  752.   (drawable (drawable event-window))
  753.   (card16 x y width height)
  754.   (card16 minor)  ;; Minor opcode
  755.   (card16 count)
  756.   (card8 major))  ;; Major opcode
  757.  
  758. (declare-event :no-exposure
  759.   (card16 sequence)
  760.   (drawable (drawable event-window))
  761.   (card16 minor)
  762.   (card8  major))
  763.  
  764. (declare-event :visibility-notify
  765.   (card16 sequence)
  766.   (window (window event-window))
  767.   ((member8 :unobscured :partially-obscured :fully-obscured) state))
  768.  
  769. (declare-event :create-notify
  770.   (card16 sequence)
  771.   (window (parent event-window) window)
  772.   (int16 x y)
  773.   (card16 width height border-width)
  774.   (boolean override-redirect-p))
  775.  
  776. (declare-event :destroy-notify
  777.   (card16 sequence)
  778.   (window event-window window))
  779.  
  780. (declare-event :unmap-notify
  781.   (card16 sequence)
  782.   (window event-window window)
  783.   (boolean configure-p))
  784.  
  785. (declare-event :map-notify
  786.   (card16 sequence)
  787.   (window event-window window)
  788.   (boolean override-redirect-p))
  789.  
  790. (declare-event :map-request
  791.   (card16 sequence)
  792.   (window (parent event-window) window))
  793.  
  794. (declare-event :reparent-notify
  795.   (card16 sequence)
  796.   (window event-window window parent)
  797.   (int16 x y)
  798.   (boolean override-redirect-p))
  799.  
  800. (declare-event :configure-notify
  801.   (card16 sequence)
  802.   (window event-window window)
  803.   ((or null window) above-sibling)
  804.   (int16 x y)
  805.   (card16 width height border-width)
  806.   (boolean override-redirect-p))
  807.  
  808. (declare-event :configure-request
  809.   ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
  810.   (card16 sequence)
  811.   (window (parent event-window) window)
  812.   ((or null window) above-sibling)
  813.   (int16 x y)
  814.   (card16 width height border-width value-mask))
  815.  
  816. (declare-event :gravity-notify
  817.   (card16 sequence)
  818.   (window event-window window)
  819.   (int16 x y))
  820.  
  821. (declare-event :resize-request
  822.   (card16 sequence)
  823.   (window (window event-window))
  824.   (card16 width height))
  825.  
  826. (declare-event :circulate-notify
  827.   (card16 sequence)
  828.   (window event-window window parent)
  829.   ((member16 :top :bottom) place))
  830.  
  831. (declare-event :circulate-request
  832.   (card16 sequence)
  833.   (window (parent event-window) window)
  834.   (pad16 1 2)
  835.   ((member16 :top :bottom) place))
  836.  
  837. (declare-event :property-notify
  838.   (card16 sequence)
  839.   (window (window event-window))
  840.   (keyword atom) ;; keyword
  841.   (card32 time)
  842.   ((member16 :new-value :deleted) state))
  843.  
  844. (declare-event :selection-clear
  845.   (card16 sequence)
  846.   (card32 time)
  847.   (window (window event-window)) 
  848.   (keyword selection) ;; keyword
  849.   )
  850.  
  851. (declare-event :selection-request
  852.   (card16 sequence)
  853.   (card32 time)
  854.   (window (window event-window) requestor)
  855.   (keyword selection target)
  856.   ((or null keyword) property)
  857.   )
  858.  
  859. (declare-event :selection-notify
  860.   (card16 sequence)
  861.   (card32 time)
  862.   (window (window event-window))
  863.   (keyword selection target)
  864.   ((or null keyword) property)
  865.   )
  866.  
  867. (declare-event :colormap-notify
  868.   (card16 sequence)
  869.   (window (window event-window))
  870.   ((or null colormap) colormap)
  871.   (boolean new-p installed-p))
  872.  
  873. (declare-event :client-message
  874.   (data format)
  875.   (card16 sequence)
  876.   (window (window event-window))
  877.   (keyword type)
  878.   ((client-message-sequence format) data))
  879.  
  880. (declare-event :mapping-notify
  881.   (card16 sequence)
  882.   ((member8 :modifier :keyboard :pointer) request)
  883.   (card8 start) ;; first key-code
  884.   (card8 count))
  885.  
  886.  
  887. ;;
  888. ;; EVENT-LOOP
  889. ;;
  890. ;;; (display-event-queue display) contains a cons whose CDR is the first event.
  891. ;;; CLX always passes around a cons BEFORE the next event to make it easy to
  892. ;;; remove events from the queue.  This is much easier than keeping track of
  893. ;;; the previous cons, and faster than using DELETE.
  894.  
  895. (defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
  896.   ;; Bind EVENT to the events for DISPLAY.
  897.   ;; This is the "GUTS" of process-event and event-case.
  898.   (let ((events (gensym)))
  899.     `(with-event-queue (,display)
  900.        (let ((,events (or *recursive-event-queue*    ; The cons before the current event
  901.               (display-event-queue ,display))))
  902.      (declare (type cons ,events))
  903.      (loop
  904.                         ; Read events when queue empty
  905.        (unless (cdr ,events)
  906.          (when (wait-for-event ,display ,timeout ,force-output-p)
  907.            (return nil)))            ; return when timeout exceeded
  908.        
  909.        (new-event-update ,display ,events)    ; Keep the new-event list updated
  910.        
  911.        (let ((,event (cadr ,events))    ; Bind *recursive-event-queue* to
  912.          (*recursive-event-queue* (cdr ,events)))   ;; the cons before the next event.
  913.          (progn ,@body)            ; Execute the body
  914.          (when (eq ,event (cadr ,events))    ; Pop event if not discarded
  915.            (if ,discard-p
  916.            (discard-current-event ,display)
  917.          (pop ,events)))
  918.          ))))))
  919.  
  920. (defun discard-current-event (display)
  921.   ;; Discard the current event for DISPLAY.
  922.   ;; Returns NIL when the event queue is empty, else T.
  923.   ;; To ensure events aren't ignored, application code should only call
  924.   ;; this when throwing out of event-case or process-next-event, or from
  925.   ;; inside even-case, event-cond or process-event when :peek-p is T and
  926.   ;; :discard-p is NIL.
  927.   (declare (type display display))
  928.   (declare-values boolean)
  929.   (if *recursive-event-queue*
  930.       (do* ((previous (display-event-queue display) queue)
  931.         (queue (cdr previous) (cdr queue))
  932.         (current-event (car *recursive-event-queue*)))
  933.        ((eq current-event (car queue))
  934.         (when queue ;; return NIL when queue is empty
  935.           (when (eq queue (display-new-events display))
  936.         ;; Deleting a new (unseen) event.
  937.         ;;   Should this signal an error?
  938.         ;;   Should we return NIL here?
  939.         ;; Assume caller knows what he's doing and
  940.         ;; update the new-event pointer.
  941.         (new-event-update display previous))
  942.  
  943.           ;; Remove event from the queue
  944.           (setf (cdr previous) (cdr queue)) 
  945.           (deallocate-event current-event)
  946.           (setq *recursive-event-queue* previous)
  947.           t))
  948.     (declare (type cons previous)
  949.          (type list queue)))
  950.     
  951.     ;; Called outside event-loop - call ourselves with the lock grabbed.
  952.     (with-event-queue (display)
  953.       (let ((*recursive-event-queue* (cdr (display-event-queue display))))
  954.     (when *recursive-event-queue*
  955.       (discard-current-event display))))))
  956.  
  957. (defun new-event-update (display event-list)
  958.   ;; Internal function called in EVENT-LOOP to keep the new-event list updated.
  959.   (declare (inline new-event-update))
  960.   ;; This isn't proclaimed in-line because the with-event-queue-internal
  961.   ;; expansion is long.  Declare inline here so compiler saves
  962.   ;; definition and this can be proclaimed inline later by users.
  963.   (with-event-queue-internal (display)
  964.     ;; When event is new, Pop the new-event list
  965.     (let ((new (display-new-events display)))
  966.       (when (eq (cdr event-list) new)
  967.     (setf (display-new-events display) (cdr new))))))
  968.  
  969. ;;
  970. ;; PROCESS-EVENT
  971. ;;
  972. (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
  973.   ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
  974.   ;; on each queued event until handler returns non-nil, and that returned object is
  975.   ;; then returned by process-event.  If peek-p is true, then the event is not
  976.   ;; removed from the queue.  If discard-p is true, then events for which handler
  977.   ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
  978.   ;; until non-nil is generated for some event, or for the specified timeout (in
  979.   ;; seconds, if given); however, it is acceptable for an implementation to wait only
  980.   ;; once on network data, and therefore timeout prematurely.  Returns nil on
  981.   ;; timeout.  If handler is a sequence, it is expected to contain handler functions
  982.   ;; specific to each event class; the event code is used to index the sequence,
  983.   ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
  984.   ;; with resource objects.  The arguments to the handler are described using declare-event.
  985.   ;;
  986.   ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
  987.   ;; from the queue (it is left in place), NIL means the event is removed.
  988.   
  989.   (declare (type display display)
  990.        (type t handler) ;; (or (sequence (function (display &rest key-vals) t))
  991.        ;;       (function (display event-key &rest key-vals) t))
  992.        (type (or null number) timeout)
  993.        (type boolean peek-p))
  994.   (event-loop (display event timeout force-output-p discard-p)
  995.     (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
  996.        (event-decoder (and (< event-code (length *event-handler-vector*))
  997.                    (aref *event-handler-vector* event-code))))
  998.       (if event-decoder
  999.       (let ((event-handler (if (functionp handler)
  1000.                    handler
  1001.                    (and (type? handler 'sequence)
  1002.                     (< event-code (length handler))
  1003.                     (elt handler event-code)))))
  1004.         (if event-handler
  1005.         (let ((result (funcall event-decoder display event event-handler)))
  1006.           (when result
  1007.             (unless peek-p
  1008.               (discard-current-event display))
  1009.             (return result)))
  1010.           (cerror "Ignore this event"
  1011.               "No handler for ~s event"
  1012.               (aref *event-key-vector* event-code))))
  1013.     (cerror "Ignore this event"
  1014.         "Server Error: event with unknown event code ~d received."
  1015.         event-code)))))
  1016.  
  1017. ;;
  1018. ;; EVENT-CASE
  1019. ;; 
  1020.  
  1021. (defmacro event-case ((&rest args) &body clauses)
  1022.   ;; If force-output-p is true, first invokes display-force-output.  Executes the
  1023.   ;; matching clause for each queued event until a clause returns non-nil, and that
  1024.   ;; returned object is then returned by event-case.  If peek-p is true, then the
  1025.   ;; event is not removed from the queue.  If discard-p is true, then events for
  1026.   ;; which the clause returns nil are removed from the queue, otherwise they are left
  1027.   ;; in place.  Hangs until non-nil is generated for some event, or for the specified
  1028.   ;; timeout (in seconds, if given); however, it is acceptable for an implementation
  1029.   ;; to wait only once on network data, and therefore timeout prematurely.  Returns
  1030.   ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
  1031.   ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
  1032.   ;; (but only in the last clause).  The keys are not evaluated, and it is an error
  1033.   ;; for the same key to appear in more than one clause.  Args is the list of event
  1034.   ;; components of interest; corresponding values (if any) are bound to variables
  1035.   ;; with these names (i.e., the args are variable names, not keywords, the keywords
  1036.   ;; are derived from the variable names).  An arg can also be a (keyword var) form,
  1037.   ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
  1038.   ;; equivalent to having one that returns nil.
  1039.   (declare-arglist (display &key timeout peek-p discard-p force-output-p)
  1040.            (event-or-events ((&rest args) |...|) &body body) |...|)
  1041.   ;; Event-case is just event-cond with the whole body in the test-form
  1042.   `(event-cond ,args
  1043.            ,@(mapcar
  1044.            #'(lambda (clause)
  1045.                `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
  1046.            clauses)))
  1047.  
  1048. ;;
  1049. ;; EVENT-COND
  1050. ;; 
  1051.  
  1052. (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
  1053.               &body clauses)
  1054.   ;; The clauses of event-cond are of the form:
  1055.   ;; (event-or-events binding-list test-form . body-forms)
  1056.   ;;
  1057.   ;; EVENT-OR-EVENTS    event-key or a list of event-keys (but they
  1058.   ;;            need not be typed as keywords) or the symbol t
  1059.   ;;            or otherwise (but only in the last clause).  If
  1060.   ;;            no t/otherwise clause appears, it is equivalent
  1061.   ;;            to having one that returns nil.  The keys are
  1062.   ;;            not evaluated, and it is an error for the same
  1063.   ;;            key to appear in more than one clause.
  1064.   ;;
  1065.   ;; BINDING-LIST    The list of event components of interest.
  1066.   ;;            corresponding values (if any) are bound to
  1067.   ;;            variables with these names (i.e., the binding-list
  1068.   ;;            has variable names, not keywords, the keywords are
  1069.   ;;            derived from the variable names).  An arg can also
  1070.   ;;            be a (keyword var) form, as for keyword args in a
  1071.   ;;            lambda list.
  1072.   ;;
  1073.   ;; The matching TEST-FORM for each queued event is executed until a
  1074.   ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
  1075.   ;; evaluated, returning the (possibly multiple) values of the last
  1076.   ;; form from event-cond.  If there are no body-forms then, if the
  1077.   ;; test-form is non-nil, the value of the test-form is returned as a
  1078.   ;; single value.
  1079.   ;;
  1080.   ;; Options:
  1081.   ;; FORCE-OUTPUT-P    When true, first invoke display-force-output if no
  1082.   ;;              input is pending.
  1083.   ;;
  1084.   ;; PEEK-P        When true, then the event is not removed from the queue.
  1085.   ;;
  1086.   ;; DISCARD-P        When true, then events for which the clause returns nil
  1087.   ;;             are removed from the queue, otherwise they are left in place.
  1088.   ;;
  1089.   ;; TIMEOUT        If NIL, hang until non-nil is generated for some event's
  1090.   ;;            test-form. Otherwise return NIL after TIMEOUT seconds have
  1091.   ;;            elapsed.
  1092.   ;;
  1093.   (declare-arglist (display &key timeout peek-p discard-p force-output-p)
  1094.            (event-or-events (&rest args) test-form &body body) |...|)
  1095.   (let ((event (gensym))
  1096.     (disp (gensym)))
  1097.     `(let ((,disp ,display)
  1098.        ,@(when (consp peek-p)
  1099.            ;; If Peek-p is a function, only evaluate it once.
  1100.            (let ((temp (gensym)))
  1101.          (prog1
  1102.            `((,temp ,peek-p))
  1103.            (setq peek-p temp)))))
  1104.        (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
  1105.      (event-dispatch (,disp ,event ,peek-p) ,@clauses)))))
  1106.  
  1107. (defun get-event-code (event)
  1108.   ;; Returns the event code given an event-key
  1109.   (declare (type event-key event))
  1110.   (declare-values card8)
  1111.   (or (get event 'event-code)
  1112.       (x-type-error event 'event-key)))
  1113.  
  1114. (defun universal-event-get-macro (display event-key variable)
  1115.   (getf
  1116.     `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
  1117.            (the card8 (logand 127 (read-card8 0))) :send-event-p
  1118.            (the boolean (logbitp 7 (read-card8 0))))
  1119.     variable))
  1120.  
  1121. (defmacro event-dispatch ((display event peek-p) &body clauses)
  1122.   ;; Helper macro for event-case
  1123.   ;; CLAUSES are of the form:
  1124.   ;; (event-or-events binding-list test-form . body-forms)
  1125.   (let ((event-key (gensym))
  1126.     (all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
  1127.     `(reading-event (,event)
  1128.        (let ((,event-key (aref *event-key-vector* (event-code ,event))))
  1129.      (case ,event-key
  1130.        ,@(mapcar
  1131.            #'(lambda (clause)        ; Translate event-cond clause to case clause
  1132.            (let* ((events (first clause))
  1133.               (arglist (second clause))
  1134.               (test-form (third clause))
  1135.               (body-forms (cdddr clause)))
  1136.              (flet ((event-clause (display peek-p first-form rest-of-forms)
  1137.                   (if rest-of-forms
  1138.                   `(when ,first-form
  1139.                      (unless ,peek-p (discard-current-event ,display))
  1140.                      (return (progn ,@rest-of-forms)))
  1141.                 ;; No body forms, return the result of the test form
  1142.                 (let ((result (gensym)))
  1143.                   `(let ((,result ,first-form))
  1144.                      (when ,result
  1145.                        (unless ,peek-p (discard-current-event ,display))
  1146.                        (return ,result)))))))
  1147.  
  1148.                (if (member events '(otherwise t))
  1149.                ;; code for OTHERWISE clause.
  1150.                ;; Find all events NOT used by other clauses
  1151.                (let ((keys (do ((i 0 (1+ i))
  1152.                         (key nil)
  1153.                         (result nil))
  1154.                        ((>= i *max-events*) result)
  1155.                      (setq key (aref *event-key-vector* i))
  1156.                      (when (and key (zerop (aref all-events i)))
  1157.                        (push key result)))))
  1158.                  `(otherwise (binding-event-values
  1159.                        (,display ,event-key ,(or keys :universal) ,@arglist)
  1160.                        ,(event-clause display peek-p test-form body-forms))))
  1161.  
  1162.              ;; Code for normal clauses
  1163.              (let (true-events) ;; canonicalize event-names
  1164.                (if (consp events)
  1165.                    (progn
  1166.                  (setq true-events (mapcar #'canonicalize-event-name events))
  1167.                  (dolist (event true-events)
  1168.                    (setf (aref all-events (get-event-code event)) 1)))
  1169.                  (setf true-events (canonicalize-event-name events)
  1170.                    (aref all-events (get-event-code true-events)) 1))
  1171.                `(,true-events (binding-event-values
  1172.                         (,display ,event-key ,true-events ,@arglist)
  1173.                         ,(event-clause display peek-p test-form body-forms))))))))
  1174.            clauses))))))
  1175.  
  1176. (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
  1177.   ;; Execute BODY with the variables in VALUE-LIST bound to components of the
  1178.   ;; EVENT-KEYS events.
  1179.   (unless (consp event-keys) (setq event-keys (list event-keys)))
  1180.   (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
  1181.      (var-symbol (var) (if (consp var) (second var) var)))
  1182.     ;; VARS is an alist of:
  1183.     ;;  (component-key ((event-key event-key ...) . extraction-code)
  1184.     ;;               ((event-key event-key ...) . extraction-code) ...)
  1185.     ;; There should probably be accessor macros for this, instead of things like cdadr.
  1186.     (let ((vars (mapcar #'(lambda (var) (list var)) value-list))
  1187.       (multiple-p nil))
  1188.       ;; Fill in the VARS alist with event-keys and extraction-code
  1189.       (do ((keys event-keys (cdr keys))
  1190.        (temp nil))
  1191.       ((endp keys))
  1192.     (let* ((key (car keys))
  1193.            (binder (case key
  1194.              (:universal #'universal-event-get-macro)
  1195.              (otherwise (aref *event-macro-vector* (get-event-code key))))))
  1196.       (dolist (var vars)
  1197.         (let ((code (funcall binder display event-key (var-key (car var)))))
  1198.           (unless code (format t "~%Warning: ~a isn't a component of the ~s event"
  1199.                    (var-key (car var)) key))
  1200.           (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
  1201.           (push key (caar temp))
  1202.         (push `((,key) . ,code) (cdr var)))))))
  1203.       ;; Bind all the values
  1204.       `(let ,(mapcar #'(lambda (var)
  1205.              (if (cddr var) ;; if more than one binding form
  1206.                  (progn (setq multiple-p t)
  1207.                     (var-symbol (car var)))
  1208.                (list (var-symbol (car var)) (cdadr var))))
  1209.              vars)
  1210.      ;; When some values come from different places, generate code to set them
  1211.      ,(when multiple-p
  1212.         `(case ,event-key
  1213.            ,@(do ((keys event-keys (cdr keys))
  1214.               (clauses nil) ;; alist of (event-keys bindings)
  1215.               (clause nil nil)
  1216.               (temp))
  1217.              ((endp keys)
  1218.               (dolist (clause clauses)
  1219.             (unless (cdar clause) ;; Atomize single element lists
  1220.               (setf (car clause) (caar clause))))
  1221.               clauses)
  1222.            ;; Gather up all the bindings associated with (car keys)
  1223.            (dolist (var vars)
  1224.              (when (cddr var) ;; when more than one binding form
  1225.                (dolist (events (cdr var))
  1226.              (when (member (car keys) (car events))
  1227.                ;; Optimize for event-window being the same as some other binding
  1228.                (if (setq temp (member (cdr events) clause :key #'caddr :test #'equal))
  1229.                    (setq clause (nconc clause `((setq ,(car var) ,(second (car temp))))))
  1230.                  (push `(setq ,(car var) ,(cdr events)) clause))))))
  1231.            ;; Merge bindings for (car keys) with other bindings
  1232.            (when clause
  1233.              (if (setq temp (member clause clauses :key #'cdr :test #'equal))
  1234.              (push (car keys) (caar temp))
  1235.                (push `((,(car keys)) . ,clause) clauses))))))
  1236.      ,@body))))
  1237.  
  1238.  
  1239. ;;;-----------------------------------------------------------------------------
  1240. ;;; Error Handling
  1241. ;;;-----------------------------------------------------------------------------
  1242.  
  1243. (eval-when (eval compile load)
  1244. (defparameter
  1245.   *xerror-vector*
  1246.   '#(unknown-error
  1247.      request-error                ; 1  bad request code
  1248.      value-error                ; 2  integer parameter out of range
  1249.      window-error                ; 3  parameter not a Window
  1250.      pixmap-error                ; 4  parameter not a Pixmap
  1251.      atom-error                    ; 5  parameter not an Atom
  1252.      cursor-error                ; 6  parameter not a Cursor
  1253.      font-error                    ; 7  parameter not a Font
  1254.      match-error                ; 8  parameter mismatch
  1255.      drawable-error                ; 9  parameter not a Pixmap or Window
  1256.      access-error                ; 10 attempt to access private resource"
  1257.      alloc-error                ; 11 insufficient resources
  1258.      colormap-error                ; 12 no such colormap
  1259.      gcontext-error                ; 13 parameter not a GContext
  1260.      id-choice-error                ; 14 invalid resource ID for this connection
  1261.      name-error                    ; 15 font or color name does not exist
  1262.      length-error                ; 16 request length incorrect;
  1263.                         ;    internal Xlib error
  1264.      implementation-error            ; 17 server is defective
  1265.      ))
  1266. )
  1267.  
  1268. (defun report-error (display event)
  1269.   ;; All errors (synchronous and asynchronous) are processed by calling
  1270.   ;; an error handler in the display.  The handler is called with the display
  1271.   ;; as the first argument and the error-key as its second argument. If handler is
  1272.   ;; an array it is expected to contain handler functions specific to
  1273.   ;; each error; the error code is used to index the array, fetching the
  1274.   ;; appropriate handler. Any results returned by the handler are ignored;;
  1275.   ;; it is assumed the handler either takes care of the error completely,
  1276.   ;; or else signals. For all core errors, additional keyword/value argument
  1277.   ;; pairs are:
  1278.   ;;    :major integer
  1279.   ;;    :minor integer
  1280.   ;;    :sequence integer
  1281.   ;;    :current-sequence integer
  1282.   ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
  1283.   ;; errors another pair is:
  1284.   ;;    :resource-id integer
  1285.   ;; For :atom errors, another pair is:
  1286.   ;;    :atom-id integer
  1287.   ;; For :value errors, another pair is:
  1288.   ;;    :value integer
  1289.   (reading-event (event)
  1290.     (let* ((error-code (read-card8 1))
  1291.        (handler (display-error-handler display))
  1292.        (handler-function
  1293.          (if (type? handler 'sequence)
  1294.          (elt handler error-code)
  1295.            handler))
  1296.        (error-key (get-error-key display error-code))
  1297.        (params (funcall (get error-key 'error-decode-function)
  1298.                 display event)))
  1299.       (unwind-protect
  1300.       (apply handler-function display error-key params)
  1301.     ;; Eat up any remaining server information
  1302.     (do ((sequence (read-card16 2))
  1303.          (current-sequence (ldb (byte 16 0) (buffer-request-number display))))
  1304.         ((or (>= sequence current-sequence)
  1305.          (buffer-input display buffer-bbuf 0 *replysize* 0)))
  1306.       (case (read-card8 0) ;; type
  1307.         (0                    ; Another error
  1308.           (report-error display event))
  1309.         (1                    ; Reply
  1310.           (return t))
  1311.         (otherwise                ; Event
  1312.           ;; Push the event in the input buffer on the display's event queue
  1313.           (let ((event (allocate-event)))
  1314.         ;; Copy into event from reply buffer
  1315.         (buffer-replace (reply-ibuf8 event)
  1316.                 (reply-ibuf8 (buffer-reply-buffer display))
  1317.                 0
  1318.                 *replysize*)
  1319.         (setf (event-code event)
  1320.               (get-internal-event-code display (read-card8 0)))
  1321.         (enqueue-event event display)))))))))
  1322.  
  1323. (defun request-name (code &optional display)
  1324.   (if (< code (length *request-names*))
  1325.       (aref *request-names* code)
  1326.     (dolist (extension (and display (display-extension-alist display)) "unknown")
  1327.       (when (= code (second extension))
  1328.     (return (first extension))))))
  1329.  
  1330. (define-condition request-error (x-error)
  1331.   (display
  1332.    error-key
  1333.    major
  1334.    minor
  1335.    sequence
  1336.    current-sequence)
  1337.   (:report report-request-error))
  1338.   
  1339. (defun report-request-error (condition stream)
  1340.   (let ((error-key (request-error-error-key condition))
  1341.     (major (request-error-major condition))
  1342.     (minor (request-error-minor condition))
  1343.     (sequence (request-error-sequence condition))
  1344.     (current-sequence (request-error-current-sequence condition)))           
  1345.     (format stream "~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
  1346.         error-key (= sequence current-sequence) sequence current-sequence major minor
  1347.         (request-name major (request-error-display condition)))))
  1348.  
  1349. (define-condition resource-error (request-error)
  1350.   (resource-id)
  1351.   (:report (lambda (condition stream)
  1352.          (report-request-error condition stream)
  1353.          (format stream " ID #x~x" (resource-error-resource-id condition)))))  
  1354.  
  1355. (define-condition unknown-error (request-error)
  1356.   (error-code)
  1357.   (:report (lambda (condition stream)
  1358.          (report-request-error condition stream)
  1359.          (format stream " Error Code ~d." (unknown-error-error-code condition)))))
  1360.  
  1361. (define-condition access-error (request-error))
  1362.  
  1363. (define-condition alloc-error (request-error))
  1364.  
  1365. (define-condition atom-error (request-error)
  1366.   (atom-id)
  1367.   (:report (lambda (condition stream)
  1368.          (report-request-error condition stream)
  1369.          (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
  1370.  
  1371. (define-condition colormap-error (resource-error))
  1372.  
  1373. (define-condition cursor-error (resource-error))
  1374.  
  1375. (define-condition drawable-error (resource-error))
  1376.  
  1377. (define-condition font-error (resource-error))
  1378.  
  1379. (define-condition gcontext-error (resource-error))
  1380.  
  1381. (define-condition id-choice-error (resource-error))
  1382.  
  1383. (define-condition illegal-request-error (request-error))
  1384.  
  1385. (define-condition length-error (request-error))
  1386.  
  1387. (define-condition match-error (request-error))
  1388.  
  1389. (define-condition name-error (request-error))
  1390.  
  1391. (define-condition pixmap-error (resource-error))
  1392.  
  1393. (define-condition value-error (request-error)
  1394.   (value)
  1395.   (:report (lambda (condition stream)
  1396.          (report-request-error condition stream)
  1397.          (format stream " Value ~d." (value-error-value condition)))))
  1398.  
  1399. (define-condition window-error (resource-error))
  1400.  
  1401. (define-condition implementation-error (request-error))
  1402.  
  1403. ;;-----------------------------------------------------------------------------
  1404. ;; Internal error conditions signaled by CLX
  1405.  
  1406. (define-condition type-error (x-error)
  1407.   (object
  1408.    type
  1409.    type-string)
  1410.   (:report (lambda (condition stream)
  1411.          (format stream "~s isn't ~@[a ~] ~s"
  1412.              (type-error-object condition)
  1413.              (type-error-type-string condition)
  1414.              (type-error-type condition)))))
  1415.  
  1416. (define-condition closed-display (x-error)
  1417.   (display)
  1418.   (:report (lambda (condition stream)
  1419.          (format stream "Attempt to use closed display ~s"
  1420.              (closed-display-display condition)))))
  1421.  
  1422. (define-condition lookup-error (x-error)
  1423.   (id display type object)
  1424.   (:report (lambda (condition stream)
  1425.          (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
  1426.              (lookup-error-id condition)
  1427.              (lookup-error-display condition)
  1428.              (lookup-error-type condition)
  1429.              (lookup-error-object condition)))))  
  1430.  
  1431. (define-condition connection-failure (x-error)
  1432.   (major-version
  1433.    minor-version
  1434.    host
  1435.    display
  1436.    reason)
  1437.   (:report (lambda (condition stream)
  1438.          (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
  1439.              (connection-failure-major-version condition)
  1440.              (connection-failure-minor-version condition)
  1441.              (connection-failure-host condition)
  1442.              (connection-failure-display condition)
  1443.              (connection-failure-reason condition)))))
  1444.   
  1445. (define-condition reply-length-error (x-error)
  1446.   (reply-length
  1447.    expected-length
  1448.    display)
  1449.   (:report (lambda (condition stream)
  1450.          (format stream "Reply length was ~d when ~d words were expected for display ~s"
  1451.              (reply-length-error-reply-length condition)
  1452.              (reply-length-error-expected-length condition)
  1453.              (reply-length-error-display condition)))))  
  1454.  
  1455. (define-condition reply-timeout (x-error)
  1456.   (timeout
  1457.    display)
  1458.   (:report (lambda (condition stream)
  1459.          (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
  1460.              (reply-timeout-timeout condition)
  1461.              (reply-timeout-display condition)))))  
  1462.  
  1463. (define-condition server-disconnect (x-error)
  1464.   (display)
  1465.   (:report (lambda (condition stream)
  1466.          (format stream "Server disconnect for display ~s"
  1467.              (server-disconnect-display condition)))))
  1468.  
  1469. (define-condition sequence-error (x-error)
  1470.   (display
  1471.    req-sequence
  1472.    msg-sequence)
  1473.   (:report (lambda (condition stream)
  1474.          (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
  1475.              (sequence-error-display condition)
  1476.              (sequence-error-req-sequence condition)
  1477.              (sequence-error-msg-sequence condition)))))  
  1478.  
  1479. (define-condition unexpected-reply (x-error)
  1480.   (display
  1481.    msg-sequence
  1482.    req-sequence
  1483.    length)
  1484.   (:report (lambda (condition stream)
  1485.          (format stream "Display ~s received a server reply when none was expected.~@
  1486.                      Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
  1487.           (unexpected-reply-display condition)
  1488.           (unexpected-reply-req-sequence condition)
  1489.           (unexpected-reply-msg-sequence condition)
  1490.           (unexpected-reply-length condition)))))
  1491.  
  1492. (define-condition missing-parameter (x-error)
  1493.   (parameter)
  1494.   (:report (lambda (condition stream)
  1495.          (let ((parm (missing-parameter-parameter condition)))
  1496.            (if (consp parm)
  1497.            (format stream "One or more of the required parameters ~a is missing."
  1498.                parm)
  1499.          (format stream "Required parameter ~a is missing or null." parm))))))
  1500.  
  1501. ;; This can be signalled anywhere a pseudo font access fails.
  1502. (define-condition invalid-font (x-error)
  1503.   (font)
  1504.   (:report (lambda (condition stream)
  1505.          (format stream "Can't access font ~s" (invalid-font-font condition)))))
  1506.  
  1507. (define-condition device-busy (x-error)
  1508.   (display)
  1509.   (:report (lambda (condition stream)
  1510.          (format stream "Device busy for display ~s"
  1511.              (device-busy-display condition)))))
  1512.  
  1513. (define-condition unimplemented-event (x-error)
  1514.   (display
  1515.    event-code)
  1516.   (:report (lambda (condition stream)
  1517.          (format stream "Event code ~d not implemented for display ~s"
  1518.              (unimplemented-event-event-code condition)
  1519.              (unimplemented-event-display condition)))))
  1520.  
  1521. (define-condition undefined-event (x-error)
  1522.   (display
  1523.    event-name)
  1524.   (:report (lambda (condition stream)
  1525.          (format stream "Event code ~d undefined for display ~s"
  1526.              (undefined-event-event-name condition)
  1527.              (undefined-event-display condition)))))
  1528.  
  1529. (define-condition absent-extension (x-error)
  1530.   (name display)
  1531.   (:report (lambda (condition stream)
  1532.          (format stream "Extension ~a isn't defined for display ~s"
  1533.              (absent-extension-name condition)
  1534.              (absent-extension-display condition)))))
  1535.  
  1536. (define-condition inconsistent-parameters (x-error)
  1537.   (parameters)
  1538.   (:report (lambda (condition stream)
  1539.          (format stream "inconsistent-parameters:~{ ~s~}"
  1540.              (inconsistent-parameters-parameters condition)))))
  1541.  
  1542. (defun get-error-key (display error-code)
  1543.   ;; Return the error-key associated with error-code
  1544.   (if (< error-code (length *xerror-vector*))
  1545.       (aref *xerror-vector* error-code)
  1546.     ;; Search the extensions for the error
  1547.     (dolist (entry (display-extension-alist display) 'unknown-error)
  1548.       (let* ((event-name (first entry))
  1549.          (first-error (fourth entry))
  1550.          (errors (third (assoc event-name *extensions*))))
  1551.     (declare (type keyword event-name)
  1552.          (type card8 first-error)
  1553.          (type list errors))
  1554.     (when (and errors
  1555.            (<= first-error error-code (+ first-error (1- (length errors)))))
  1556.       (return (nth (- error-code first-error) errors)))))))
  1557.  
  1558. (defmacro define-error (error-key function)
  1559.   ;; Associate a function with ERROR-KEY which will be called with
  1560.   ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of
  1561.   ;; keyword/value pairs which will be passed on to the error handler.
  1562.   ;; A compiler warning is printed when ERROR-KEY is not defined in a
  1563.   ;; preceding DEFINE-EXTENSION.
  1564.   ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
  1565.   ;;       macros for getting error fields. See DECODE-CORE-ERROR for
  1566.   ;;       an example.
  1567.   (declare (type symbol error-key)
  1568.        (type function function))
  1569.   ;; First ensure the name is for a declared extension
  1570.   (unless (or (find error-key *xerror-vector*)
  1571.           (dolist (extension *extensions*)
  1572.         (when (member error-key (third extension))
  1573.           (return t))))
  1574.     (x-type-error error-key 'error-key))
  1575.   `(setf (get ',error-key 'error-decode-function) (function ,function)))
  1576.  
  1577. ;; All core errors use this, so we make it available to extensions.
  1578. (defun decode-core-error (display event &optional arg)
  1579.   ;; All core errors have the following keyword/argument pairs:
  1580.   ;;    :major integer
  1581.   ;;    :minor integer
  1582.   ;;    :sequence integer
  1583.   ;;    :current-sequence integer
  1584.   ;; In addition, many have an additional argument that comes from the
  1585.   ;; same place in the event, but is named differently.  When the ARG
  1586.   ;; argument is specified, the keyword ARG with card32 value starting
  1587.   ;; at byte 4 of the event is returned with the other keyword/argument
  1588.   ;; pairs.
  1589.   (declare (type display display)
  1590.        (type reply-buffer event)
  1591.        (type (or null keyword) arg))
  1592.   (declare-values keyword/arg-plist)
  1593.   (reading-event (event)
  1594.     (let* ((sequence (read-card16 2))
  1595.        (minor-code (read-card16 8))
  1596.        (major-code (read-card8 10))
  1597.        (current-sequence (ldb (byte 16 0) (buffer-request-number display)))
  1598.        (result (list :major major-code
  1599.              :minor minor-code
  1600.              :sequence sequence
  1601.              :current-sequence current-sequence)))
  1602.       (when arg
  1603.     (setq result (list* arg (read-card32 4) result)))
  1604.       result)))
  1605.  
  1606. (defun decode-resource-error (display event)
  1607.   (decode-core-error display event :resource-id))
  1608.  
  1609. (define-error unknown-error
  1610.   (lambda (display event)
  1611.     (list* :error-code (aref (reply-ibuf8 event) 1)
  1612.        (decode-core-error display event))))
  1613.  
  1614. (define-error request-error decode-core-error)        ; 1  bad request code
  1615.  
  1616. (define-error value-error                ; 2  integer parameter out of range
  1617.   (lambda (display event)
  1618.     (decode-core-error display event :value)))
  1619.  
  1620. (define-error window-error decode-resource-error)    ; 3  parameter not a Window
  1621.  
  1622. (define-error pixmap-error decode-resource-error)    ; 4  parameter not a Pixmap
  1623.  
  1624. (define-error atom-error                ; 5  parameter not an Atom
  1625.   (lambda (display event)
  1626.     (decode-core-error display event :atom-id)))
  1627.  
  1628. (define-error cursor-error decode-resource-error)    ; 6  parameter not a Cursor
  1629.  
  1630. (define-error font-error decode-resource-error)        ; 7  parameter not a Font
  1631.  
  1632. (define-error match-error decode-core-error)        ; 8  parameter mismatch
  1633.  
  1634. (define-error drawable-error decode-resource-error)    ; 9  parameter not a Pixmap or Window
  1635.  
  1636. (define-error access-error decode-core-error)        ; 10 attempt to access private resource"
  1637.  
  1638. (define-error alloc-error decode-core-error)        ; 11 insufficient resources
  1639.  
  1640. (define-error colormap-error decode-resource-error)    ; 12 no such colormap
  1641.  
  1642. (define-error gcontext-error decode-resource-error)    ; 13 parameter not a GContext
  1643.  
  1644. (define-error id-choice-error decode-resource-error)    ; 14 invalid resource ID for this connection
  1645.  
  1646. (define-error name-error decode-core-error)        ; 15 font or color name does not exist
  1647.  
  1648. (define-error length-error decode-core-error)        ; 16 request length incorrect;
  1649.                             ;    internal Xlib error
  1650.  
  1651. (define-error implementation-error decode-core-error)    ; 17 server is defective
  1652.